home *** CD-ROM | disk | FTP | other *** search
/ Programming Languages Suite / ProgramD2.iso / Borland / Borland Pascal with Objects 7.0 / HEAPSPY.ZIP / HEAPSPY.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1992-10-27  |  11.1 KB  |  421 lines
  1. {$A-,B-,E-,F-,G+,I-,K-,N-,O-,P-,Q-,R-,S-,T+,V-,W-,X+}
  2. {$M 8192,8192}
  3.  
  4. {**********************************************}
  5. {                                              }
  6. {   HeapSpy - Main Module                      }
  7. {   Copyright (c) 1992  Borland International  }
  8. {                                              }
  9. {**********************************************}
  10.  
  11. program HeapSpy;
  12.  
  13. {$C MOVEABLE PRELOAD PERMANENT}
  14.  
  15. {$R HEAPSPY.RES}
  16. {$D HeapSpy Version 1.0}
  17.  
  18. uses WinTypes, WinPRocs, Strings, Objects, ODialogs, OWindows, BWCC,
  19.  WinDOS, Win31, ToolHelp, HWGlobal, HWDlgs, HWClass, HWHexDmp,
  20.  HWBitmap, HWLocal, HWTPWh, HWHeap, HWGraph, HWRibbon;
  21.  
  22. {$S 65535}
  23. {$G HeapSpy, System, HWGlobal, HWRibbon}
  24. {$G HWDlgs}
  25. {$G HWClass}
  26. {$G HWHexDmp}
  27. {$G HWBitMap}
  28. {$G HWLocal}
  29. {$G HWTPWh}
  30. {$G HWHeap}
  31. {$G WinDos, Strings}
  32. {$G Objects, OWindows, ODialogs, OMemory, BWCC}
  33.  
  34. type
  35.   PMDIApp = ^TMDIApp;
  36.   TMDIApp = object(TApplication)
  37.     procedure InitMainWindow; virtual;
  38.  end;
  39.  
  40.   PHeapSpyMDIWindow = ^THeapSpyMDIWindow;
  41.   THeapSpyMDIWindow = object(TMDIWINDOW)
  42.     StatusLine: PRibbonWindow;
  43.     SpeedBar: PSpeedBar;
  44.     constructor Init(ATitle: Pchar; AMenu: THandle);
  45.     function InitChild: PWindowsObject; virtual;
  46.     procedure GetWindowClass(var WndClass: TWndClass); virtual;
  47.     procedure InitClientWindow; virtual;
  48.     procedure WMSize(var Msg: TMessage);
  49.       virtual wm_First + wm_Size;
  50.     procedure WMMenuSelect(var Msg: TMessage);
  51.       virtual wm_First + wm_MenuSelect;
  52.     procedure WMDestroy(var Msg: TMessage);
  53.       virtual wm_First + wm_Destroy;
  54.     procedure CMAbout(var Msg: Tmessage);
  55.       virtual cm_First + cm_About;
  56.     procedure CMClose(var Msg: TMessage);
  57.       virtual cm_First + cm_Close;
  58.     procedure CMCreateAll(var Msg: TMessage);
  59.       virtual cm_First + cm_CreateAll;
  60.     procedure CMCreateFree(var Msg: TMessage);
  61.       virtual cm_First + cm_CreateFree;
  62.     procedure CMCreateClass(var Msg: TMessage);
  63.       virtual cm_First + cm_CreateClass;
  64.     procedure CMHeapGraph(var Msg: Tmessage);
  65.       virtual cm_First + cm_HeapGraph;
  66.     procedure CMOptions(var Msg: TMessage);
  67.       virtual cm_First + cm_Options;
  68.     procedure CMGDIWalk(var Msg: TMessage);
  69.       virtual cm_First + cm_GDIWalk;
  70.     procedure CMUserWalk(var Msg: TMessage);
  71.       virtual cm_First + cm_UserWalk;
  72.     procedure CMMemInfo(var Msg: TMessage);
  73.       virtual cm_First + cm_meminfo;
  74.     procedure CMHelpContents(var Msg: TMessage); virtual
  75.       cm_First + cm_HelpContents;
  76.     procedure CMListFont(var Msg: TMessage);
  77.       virtual cm_First + cm_ListFont;
  78.     procedure CMHexFont(var Msg: TMessage);
  79.       virtual cm_First + cm_HexFont;
  80.     procedure CreateSpeedbar;
  81.     procedure UpdateSpeedbar(var Msg: TMessage); virtual
  82.       wm_First + user_UpdateSpeed;
  83.   end;
  84.  
  85.   PHeapSpyMDIClient = ^THeapSpyMDIClient;
  86.   THeapSpyMDIClient = object(TMDIClient)
  87.     procedure TileChildren; virtual;
  88.   end;
  89.  
  90. constructor THeapSpyMDIWindow.Init(ATitle: Pchar; AMenu: THandle);
  91. begin
  92.   inherited Init(ATitle,AMenu);
  93.   Attr.X := 0;
  94.   Attr.Y := 0;
  95.   StatusLine := New(PRibbonWindow,Init(@Self));
  96.   if Glbl.UseSpeedBar then
  97.     CreateSpeedBar
  98.   else
  99.     SpeedBar := nil;
  100. end;
  101.  
  102. procedure THeapSpyMDIWindow.CreateSpeedBar;
  103. begin
  104.  SpeedBar := New(PSpeedBar,Init(@Self,StatusLine));
  105.  with SpeedBar^ do
  106.  begin
  107.    AddATool(cm_HelpContents,Pchar(cm_HelpContents));
  108.    AddATool(cm_CreateChild,Pchar(cm_CreateChild));
  109.    AddATool(cm_SaveAs,Pchar(cm_SaveAs));
  110.    AddATool(cm_Options,Pchar(cm_options));
  111.    AddATool(cm_Rebuild,Pchar(cm_rebuild));
  112.  end;
  113. end;
  114.  
  115. procedure THeapSpyMDIWindow.UpdateSpeedBar;
  116. var
  117.   Rect: TRect;
  118.   SendSizeMsg: Boolean;
  119.   SizeMsg: TMessage;
  120. begin
  121.   SendSizeMsg := False;
  122.   if glbl.UseSpeedBar and (SpeedBar = nil) then
  123.   begin
  124.     CreateSpeedBar;
  125.     Application^.MakeWindow(SpeedBar);
  126.     SendSizeMsg := True;
  127.   end
  128.   else if (not glbl.UseSpeedBar) and (SpeedBar <> nil) then
  129.   begin
  130.     SpeedBar^.Free;
  131.     SpeedBar := nil;
  132.     SendSizeMsg := True;
  133.   end;
  134.   if SendSizeMsg then
  135.   begin
  136.     GetClientRect(hWindow,Rect);
  137.     SizeMsg.lParamLo := Rect.Right;
  138.     SizeMsg.lParamHi := Rect.Bottom;
  139.     WMSize(SizeMsg);
  140.   end;
  141. end;
  142.  
  143. procedure THeapSpyMDIWindow.WMSize(var Msg: TMessage);
  144. var
  145.   ClientX,ClientY,
  146.   StatusX,StatusY,
  147.   SpeedX,SpeedY,
  148.   ClientW,ClientH,
  149.   StatusW,StatusH,
  150.   SpeedW,SpeedH: integer;
  151. begin
  152.   ClientX := 0; ClientY := 0;
  153.   ClientW := Msg.lParamLo;  ClientH := Msg.lParamHi;
  154.  
  155.   if StatusLine <> nil then
  156.   with StatusLine^ do
  157.   begin
  158.     StatusX := ClientX-1; StatusY := ClientH-Height;
  159.     StatusW := ClientW+2;  StatusH := Height+1;
  160.     Dec(ClientH,Height);
  161.     if StatusLine^.hWindow <> 0 then
  162.       MoveWindow(StatusLine^.hWindow,StatusX,StatusY,StatusW,StatusH,True);
  163.   end;
  164.  
  165.   if SpeedBar <> nil then
  166.   begin
  167.     SpeedX := ClientX;
  168.     Dec(ClientY);
  169.     SpeedY := ClientY;
  170.     SpeedW := ClientW+1;
  171.     SpeedH := SpeedBar^.Attr.H;
  172.     Inc(ClientY,SpeedH);
  173.     Dec(ClientH,Pred(SpeedH));
  174.     if SpeedBar^.hWindow <> 0 then
  175.        MoveWindow(SpeedBar^.hWindow,SpeedX,SpeedY,SpeedW,SpeedH,True);
  176.   end;
  177.  
  178.   if (ClientWnd <> nil) and (ClientWnd^.HWindow <> 0) then
  179.     MoveWindow(ClientWnd^.HWindow, ClientX,ClientY,ClientW,ClientH,True);
  180. end;
  181.  
  182. procedure THeapSpyMDIWindow.WMMenuSelect;
  183. var
  184.   HelpText: array[0..80] of char;
  185.   I, StrIdx: word;
  186. const
  187.   Popuphandles: array[0..5] of word = (0,0,0,0,0,0);
  188. begin
  189.  if PopupHandles[0] = 0 then
  190.    for i := 0 to 5 do
  191.      PopupHandles[i] := GetSubMenu(Attr.Menu,i);
  192.  
  193.   if StatusLine = nil then exit;
  194.  
  195.   HelpText[0] := #0;
  196.   if Msg.LParamLo <> $FFFF then
  197.   begin
  198.     StrIdx := Msg.wParam;
  199.     if (Msg.lParamLo and MF_POPUP) <> 0 then
  200.     begin
  201.       I := 0;
  202.       StrIdx := 0;
  203.       repeat
  204.         if PopupHandles[I] = Msg.wParam then StrIdx := 1000+i;
  205.         inc(I);
  206.       until (I > 5) or (StrIdx <> 0);
  207.     end;
  208.     if (StrIdx >= $0F00) and (StrIdx <= $0F0A) then
  209.       StrCopy(HelpText,'Make this window Current')
  210.     else if (StrIdx <> 0) and (StrIdx < $F000) then
  211.       LoadString(hInstance,StrIdx,HelpText,80);
  212.   end;
  213.   StatusLine^.SetHelpText(HelpText);
  214.   DefWndProc(Msg);
  215. end;
  216.  
  217. procedure THeapSpyMDIWindow.GetWindowClass;
  218. begin
  219.   inherited GetWindowClass(WndClass);
  220.   WndClass.hIcon := LoadIcon(HInstance, PChar(ico_Main));
  221.   WndClass.hbrBackground := COLOR_APPWORKSPACE+1;
  222. end;
  223.  
  224. function THeapSpyMDIWindow.InitChild;
  225. var
  226.   ModuleName: array[0..30] of char;
  227. begin
  228.   InitChild := nil;
  229.   if Application^.ExecDialog(New(PModuleDlg, Init(@Self, 'SELMOD',
  230.       ModuleName))) = id_OK then
  231.     if ModuleName[0] <> #0 then
  232.     begin
  233.       UpdateWindow(ClientWnd^.hWindow);
  234.       InitChild := New(PHeapWin,Init(@Self,ModuleName));
  235.     end;
  236. end;
  237.  
  238. procedure THeapSpyMDIWindow.CMClose;
  239. var
  240.   ChildWin: LongInt;
  241. begin
  242.  ChildWin := SendMessage(hWindow,WM_MDIGETACTIVE,0,0);
  243.  if LoWord(ChildWin) <> 0 then
  244.     SendMessage(ClientWnd^.hWindow,WM_MDIDESTROY,LoWord(ChildWin),0);
  245. end;
  246.  
  247. procedure THeapSpyMDIWindow.CMCreateAll;
  248. begin
  249.   Application^.MakeWindow(New(PHeapWin,Init(@Self,'All Heap Blocks')));
  250. end;
  251.  
  252. procedure THeapSpyMDIWindow.CMCreateFree(var Msg: TMEssage);
  253. begin
  254.   Application^.MakeWindow(New(PHeapWin,Init(@Self,'Free Blocks')));
  255. end;
  256.  
  257. procedure THeapSpyMDIWindow.CMHeapGraph;
  258. var
  259.   GraphWin: PWindowsObject;
  260.  
  261.   function IsAGraphWin(PWin: PWindowsObject): Boolean; far;
  262.   begin
  263.     IsAGraphWin := TypeOf(PWin^) = TypeOf(TBarGraphWin);
  264.   end;
  265.  
  266. begin
  267.   GraphWin := FirstThat(@IsAGraphWin);
  268.   if GraphWin <> nil then
  269.     SendMessage(ClientWnd^.hWindow,WM_MDIACTIVATE,GraphWin^.hWindow,0)
  270.   else
  271.     Application^.MakeWindow(New(PBarGraphWin,Init(@Self,'Heap Usage')));
  272. end;
  273.  
  274. procedure THeapSpyMDIWindow.CMCreateClass;
  275. var
  276.   ClassWin: PWindowsObject;
  277.  
  278.   function IsAClassWin(PWin: PWindowsObject): Boolean; far;
  279.   begin
  280.     IsAClassWin := TypeOf(PWin^) = TypeOf(TClassWin);
  281.   end;
  282.  
  283. begin
  284.   ClassWin := FirstThat(@IsAClassWin);
  285.   if ClassWin <> nil then
  286.     SendMessage(ClientWnd^.hWindow,WM_MDIACTIVATE,ClassWin^.hWindow,0)
  287.   else
  288.     Application^.MakeWindow(New(PClassWin,Init(@Self,'Window Classes',True)));
  289. end;
  290.  
  291. procedure THeapSpyMDIWindow.CMUserWalk;
  292. var
  293.   SHI: TSysHeapInfo;
  294. begin
  295.   SHI.dwSize := SizeOf(TSysHeapInfo);
  296.   SystemHeapInfo(@SHI);
  297.   Application^.MakeWindow(New(PLocalWin,Init(@Self,SHI.hUserSegment,'USER')));
  298. end;
  299.  
  300. procedure THeapSpyMDIWindow.CMGDIWalk;
  301. var
  302.   SHI: TSysHeapInfo;
  303. begin
  304.   SHI.dwSize := SizeOf(TSysHeapInfo);
  305.   SystemHeapInfo(@SHI);
  306.   Application^.MakeWindow(New(PLocalWin,Init(@Self,SHI.hGDISegment,'GDI')));
  307. end;
  308.  
  309. procedure THeapSpyMDIWindow.CMAbout;
  310. begin
  311.   Application^.ExecDialog(New(PAbtDlg,Init(@Self,'About')));
  312. end;
  313.  
  314. procedure THeapSpyMDIWindow.CMOptions;
  315. begin
  316.   Application^.ExecDialog(New(POptionDlg,Init(ClientWnd,'HWOPTIONS')));
  317. end;
  318.  
  319. procedure THeapSpyMDIWindow.CMListFont;
  320. var
  321.   Dummy: LongInt;
  322.  
  323.   procedure UpdateFont(Item: PWindowsObject); far;
  324.   begin
  325.     if DescendantOf(TypeOf(TListWin), TypeOf(Item^)) then
  326.     with PListWin(Item)^ do begin
  327.       SendMessage(List^.hWindow,WM_SETFONT,ListBoxFont,1);
  328.       RebuildWindow(Msg);
  329.     end;
  330.   end;
  331.  
  332. begin
  333.   if DoFontDialog(@Self,@HeapFontLF,'Heap List Font') then
  334.   begin
  335.     if ListBoxFont <> 0 then
  336.       DeleteObject(ListBoxFont);
  337.     ListBoxFont := CreateFontIndirect(HeapFontlf);
  338.     Application^.MainWindow^.ForEach(@UpdateFont);
  339.   end;
  340. end;
  341.  
  342. procedure THeapSpyMDIWindow.CMHexFont;
  343. var
  344.   Dummy: LongInt;
  345.  
  346.   procedure UpdateFont(Item: PWindow); far;
  347.   begin
  348.     if DescendantOf(TypeOf(TBasicHexWin),TypeOf(Item^)) then
  349.       SendMessage(Item^.hWindow,WM_SETFONT,HexDumpFont,1);
  350.   end;
  351.  
  352. begin
  353.   if DoFontDialog(@Self,@HexDumpLF,'Hex Dump Font') then
  354.   begin
  355.     if HexDumpFont <> 0 then
  356.       DeleteObject(HexDumpFont);
  357.     HexDumpFont := CreateFontIndirect(HexDumplf);
  358.     Application^.MainWindow^.ForEach(@UpdateFont);
  359.   end;
  360. end;
  361.  
  362.  
  363. procedure THeapSpyMDIWindow.CMHelpContents;
  364. begin
  365.   DoHelp(help_Index, 0);
  366. end;
  367.  
  368. procedure THeapSpyMDIWindow.CMMemInfo;
  369. begin
  370.   Application^.ExecDialog(New(PMemDlg, Init(@Self, 'MEMINFO',
  371.     menu_Heap_MemInfo)));
  372. end;
  373.  
  374. procedure THeapSpyMDIWindow.InitClientWindow;
  375. begin
  376.   ClientWnd := New(PHeapSpyMDIClient, Init(@Self));
  377.   with clientwnd^.Attr do
  378.     Style := Style or ws_VScroll or ws_HScroll;
  379. end;
  380.  
  381. procedure THeapSpyMDIWindow.WMDestroy;
  382. begin
  383.   CloseHelp;
  384.   inherited WMDestroy(Msg);
  385. end;
  386.  
  387.  
  388. procedure THeapSpyMDIClient.TileChildren;
  389. begin
  390.   if TilingMethod = op_vertical then
  391.     SendMessage(HWindow, wm_MDITile, MDITile_Vertical, 0)
  392.   else
  393.     SendMessage(HWindow, wm_MDITile, MDITile_Horizontal, 0);
  394. end;
  395.  
  396. procedure TMDIApp.InitMainWindow;
  397. begin
  398.   MainWindow := New(PHeapSpyMDIWindow, Init('Heap Spy',
  399.     LoadMenu(HInstance, PChar(mnu_main))));
  400.   PMDIWindow(MainWindow)^.ChildMenuPos := 5;
  401. end;
  402.  
  403. var
  404.   MDIApp: TMDIApp;
  405.  
  406. const
  407.   Copyright: PChar = 'Copyright (c) 1992  Borland International';
  408.  
  409. begin
  410.   if Copyright <> nil then;
  411.   if LoWord(GetVersion) <> $0A03 then
  412.     MessageBox(0,'This application requires Windows 3.1', AppName,
  413.       mb_OK or mb_IconHand)
  414.   else
  415.   begin
  416.     MDIApp.Init(AppName);
  417.     MDIApp.Run;
  418.     MDIApp.Done;
  419.   end;
  420. end.
  421.